home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
ada
/
gwuada_9.zip
/
BLIB.C
< prev
next >
Wrap
C/C++ Source or Header
|
1993-07-27
|
30KB
|
1,013 lines
/*
* Copyright (C) 1985-1992 New York University
*
* This file is part of the Ada/Ed-C system. See the Ada/Ed README file for
* warranty (none) and distribution info and also the GNU General Public
* License for more details.
*/
#define GEN
#include "hdr.h"
#include "libhdr.h"
#include "vars.h"
#include "segment.h"
#include "gvars.h"
#include "ops.h"
#include "type.h"
#include "ifile.h"
#include "axqrp.h"
#include "genp.h"
#include "segmentp.h"
#include "ginterp.h"
#include "setp.h"
#include "bmainp.h"
#include "gutilp.h"
#include "dclmapp.h"
#include "libp.h"
#include "libfp.h"
#include "librp.h"
#include "glibp.h"
#include "miscp.h"
#include "gmiscp.h"
#include "smiscp.h"
#include "gnodesp.h"
#include "blibp.h"
static void update_elaborate(char *);
static void main_code_segment();
static Tuple delayed_map_get(int);
static void delayed_map_put(int, Tuple);
static void delayed_map_undef(int);
static void add_code(char *);
static int needs_body_bnd(char *);
static int depth_level(char *);
static Tuple build_relay_sets(char *, int);
static void update_subunit_context(char *);
static int load_binding_unit(char *);
static char *read_binding_ais(char *, char *);
extern int ADA_MIN_INTEGER, ADA_MAX_INTEGER;
extern int adacomp_option;
extern long ADA_MIN_FIXED, ADA_MAX_FIXED;
extern Segment CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
extern IFILE *AXQFILE, *LIBFILE, *AISFILE, *STUBFILE;
/* variables used only by binder */
static Symbol mainunit_sym;
int binder(Tuple aisread_tup) /*;binder*/
{
/*
* BINDER checks the program library of a given main program for
* completeness. Missing modules are printed.
* Otherwise, idle_task and main_task are generated. idle_task calls
* the initialization procedures required to elaborate the various
* units in (one of) the order(s) prescribed by the language
*/
char *name, *body, *main_name, *s_name;
int prior, unit, name_num, delayed_unit;
Set elaborated, idle_precedes, precedes;
struct unit *pUnit;
Tuple missing_units, to_check, to_bind, u_slots, tup;
Tuple elaboration_table, compiled_units, delayed, s, u_rs;
Fortup ft1;
Forset fs1;
Unitdecl ud;
int i, n;
int is_interfaced_bind_unit_now;
#ifdef DEBUG
Tuple axq_needed; /* list of predefined units */
#endif
/* Reset global tuple of node and symbols for binder. */
seq_node_n = 0;
seq_node = tup_new(SEQ_NODE_INC);
seq_symbol_n = 0;
/* Miscelleanous variables needed for code generation */
LOCAL_REFERENCE_MAP = local_reference_map_new();
RELAY_SET = tup_new(0);
/*
* POSITION and PATCHES is stored in EMAP and is set implicitly when a new
* EMAP is created for a symbol and therefore is not needed here.
*
* POSITION = {};
* PATCHES = {};
*/
CURRENT_LEVEL = 0;
LAST_OFFSET = 0;
MAX_OFFSET = 0;
call_lib_unit = tup_new(0);
if (streq(MAINunit, "")) {
to_check = tup_new(0);
/* collect all possible main units i.e. all parameterless subprograms
* which are not proper bodies (subunits).
*/
for (i = 15; i <= unit_numbers; i++) {
struct unit *pUnit = pUnits[i];
if (pUnit->isMain && !streq("ma", unit_name_type(pUnit->name)))
to_check = tup_with(to_check,pUnit->name);
}
if (tup_size(to_check) == 0) {
user_error("No subprogram in library");
return FALSE;
}
else if (tup_size(to_check) == 1) {
main_name = tup_frome(to_check);
MAINunit = unit_name_name(main_name);
}
else {
user_error(
"Several subprograms in library please specify main from:");
FORTUP(name = (char *), to_check, ft1);
user_info(unit_name_name(name));
ENDFORTUP(ft1);
return FALSE;
}
}
else {
main_name = strjoin("su", MAINunit);
}
if (!load_binding_unit(main_name)) {
/* message cannot retrieve... already printed */
return FALSE;
}
update_elaborate(main_name);
ud = unit_decl_get(main_name);
mainunit_sym = ud->ud_unam;
if (NATURE(mainunit_sym) != na_procedure /* only procedures */
|| tup_size(SIGNATURE(mainunit_sym)) != 0) { /* without parameters */
user_error(strjoin(formatted_name(main_name),
" is not a valid main program."));
return FALSE;
}
name = strjoin(MAINunit, "_idle_task");
/* The name of the binding unit is "ma" followed by the name */
/* In SETL unit_name was ['main_unit', name] */
/* Note that this may create a new unit */
unit_name = strjoin("ma", name);
unit_number_now = unit_number(unit_name);
lib_unit_put(unit_name, AISFILENAME);
/* Symbol table initialized with 'main_task_type' */
symbol_main_task_type = sym_new(na_task_type);
TYPE_OF(symbol_main_task_type) = symbol_main_task_type;
SIGNATURE(symbol_main_task_type) = tup_new(0);
ALIAS(symbol_main_task_type) = symbol_main_task_type;
ORIG_NAME(symbol_main_task_type) = "main_task_type";
DECLARED(symbol_main_task_type) = dcl_new(0);
TYPE_KIND(symbol_main_task_type) = TK_WORD;
TYPE_SIZE(symbol_main_task_type) = su_size(TK_WORD);
#ifdef TBSL
/* REFERENCE_MAP = {['main_task_type', [1, 47]]}; */
S_SEGMENT(symbol_main_task_type) = 1;
S_OFFSET(symbol_main_task_type) = 47;
#endif
MISC(symbol_main_task_type) = (char *)TRUE;
/* Here we duplicate that part of the code from init_gen needed
* when starting a new unit
*
* Set initial unit_slots map to null value
* assume unit_number_now gives curent unit number; the correct
* assignment of this may best be done elsewhere
*/
tup = tup_new(5);
for (i = 1; i <= 5; i++)
tup[i] = (char *) tup_new(0);
unit_slots_put(unit_number_now, tup);
to_check = tup_new1(main_name);
idle_precedes = set_new1((char *) unit_numbered(main_name));
to_bind = tup_new(0);
missing_units = tup_new(0);
compiled_units = tup_new(unit_numbers);
for (i = 1; i <= unit_numbers; i++)
compiled_units[i] = pUnits[i]->libUnit;
/* check that any needed unit has been compiled.
*
* All units needed (directly or indirectly) by main_name are checked.
* The order in which these checks are performed is unimportant. The
* ordering map 'precedes' has been loaded from library, for later use
* in a topological sort.
*
* All units needed, but not referenced by with clauses (typically
* package bodies, procedure bodies and subunits) are noted into
* idle_precedes to make later idle_task depend on them, in order to
* suppress the binding unit if they are recompiled.
*/
while (tup_size(to_check)!= 0) {
/* always load the item at the front of the queue so that specs are
* read before their bodies.
* TBSL: this is due to the fact that the body sometimes contains
* info that is not in the spec(e.g. ASSOC_SYMBOLS) and since they share
* the same symbol the info would be overridden by the spec if the spec
* was read last.
*/
name = tup_fromb(to_check);
if (is_generic(name))
continue;
/* Check to see whether a package specification requires a body and
* if yes, that the body has been compiled.
*/
if (streq(unit_name_type(name), "sp")
|| streq(unit_name_type(name), "bo")) {
/* AXQ needed */
if (!load_binding_unit(name))
missing_units = tup_with(missing_units, name);
else
update_elaborate(name);
}
/* Collect the stubs of the current unit. */
s = stubs(name);
/*
* to_check +:= s;
* missing_units +:= s - compiled_units;
* idle_precedes +:= s;
*/
FORTUP(s_name = (char *), s, ft1);
if (!tup_memstr(s_name, to_check))
to_check = tup_with(to_check, s_name);
if (!tup_memstr(s_name, compiled_units))
missing_units = tup_with(missing_units, s_name);
idle_precedes = set_with(idle_precedes,
(char *) unit_numbered(s_name));
ENDFORTUP(ft1);
if (streq(unit_name_type(name), "sp")) {
body = strjoin("bo", unit_name_name(name));
if (tup_memstr(body, compiled_units)) {
to_check = tup_with(to_check, body);
idle_precedes = set_with(idle_precedes,
(char *)unit_numbered(body));
}
else if (needs_body_bnd(name))
missing_units = tup_with(missing_units, body);
}
else if (streq(unit_name_type(name), "ss")) {
/* Suprogram body must be present.*/
body = strjoin("su", unit_name_name(name));
if (tup_memstr(body, compiled_units) && load_binding_unit(body)) {